Poniższy kod działa tylko na mac os i ma sens jedynie gdy mamy niepolskie ustawienia dat i czasu a chcemy zmienić na polskie. W przypadku właściwych - polskich - ustawień nazwy dni i miesięcy powinny wyświetlać się nam po polsku. Jeśli nazwy są niepolskie kod zmieniający kolejność dni w punkcie o kalendarzach i mapach cieplnych nie będzie działał prawidłowo.
Według Dana Roama autora ksiażki “Narysuj swoje myśli” oś czasu jest modelem wizualnym ilustrującym odpowiedź na pytanie “kiedy”. Najprościej stworzyć timeline używając funkcji geom_segment() ggplot2.
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.3 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.0
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
Użyjemy danych dotyczących dat publikacji i liczby słów w książkach z sag A. Sapkowskiego i G.R.R. Martina.
fantasy <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/fantasy.csv")
## New names:
## Rows: 12 Columns: 6
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (2): title, author dbl (4): ...1, number, rok, words
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`
head(fantasy)
Poniższy wykres jest połączeniem wykresu lizakowego (lollypop chart) z osią czasu. Lizaki - słupki a właściwie odcinki zakończone punktem - oznaczać będą daty kolejnych książek
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open')) +
geom_segment(aes(x = rok,
y = words,
xend = rok),
yend = 0) +
geom_point(aes(x = rok,
y = words)) +
geom_text(aes(x = rok,
y = words,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
scale_x_continuous() +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0)
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
fantasy %>% filter(author == "Martin") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2, 1.5, 0.5)) %>%
ggplot() +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = disloc)) +
# kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
fantasy %>% filter(author == "Martin") %>%
# wysokość lizaków = liczba słow
ggplot() +
geom_segment(aes(x = rok,
y = words,
xend = rok),
yend = 0) +
#rysuję oś czasu
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,
y = words,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words)) +
# kontroluję etykiety na skali ręcznie wybierając tylko lata publikacji książek
scale_x_continuous(breaks = c(1996, 1999, 2000, 2005, 2011)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 7 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Stwórzmy analogiczny wykres dla książek Sapkowskiego. Spróbujmy dodać daty wydania książek na osi x.
fantasy %>% filter(author == "Sapkowski") %>%
# dodaje zmienną disloc, której użyję do mapowania wysokości lizaków
mutate(disloc = c(0.5, 1, -0.5, -1, 2)) %>%
ggplot() +
geom_segment(aes(x = 1990,
y = 0,
xend = 2001,
yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'open')) +
geom_segment(aes(x = rok,
y = disloc,
xend = rok),
yend = 0) +
geom_point(aes(x = rok,
y = disloc)) +
ggrepel::geom_text_repel(aes(x = rok,
y = disloc,
label = title),
hjust = 1.0,vjust = 1.0,
size = 4) +
scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999)) +
theme_minimal() +
theme(axis.title.x = element_blank(), #usuwa tytuł
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2001, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 5 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
ggrepel::geom_text_repel(aes(x = rok,y = words,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text_repel()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text(aes(x = rok,y = words,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Wykres panelowy:
fantasy %>%
ggplot() +
geom_segment(aes(x = rok, y = words,xend = rok),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1993,y = 0,xend = 2012,yend = 0),
arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
geom_text(aes(x = rok,y = words,label = title), hjust = 0.5,vjust = - 0.5, size = 4) +
geom_point(aes(x = rok,
y = words)) +
scale_x_continuous(breaks = c(1994, 1995, 1996, 1997, 1999, 2000,2005, 2011)) +
scale_y_continuous(limits = c(0, 450000)) +
theme_bw() +
labs(y = "słowa") +
theme(axis.title.x = element_blank(), #usuwa podpis na osi x
#axis.title.y = element_blank(),
axis.text.y = element_blank(), # usuwa tekst etykiet na osi y
text = element_text(size = 15)) +
facet_wrap(~author, nrow =2)
## Warning in geom_segment(aes(x = 1993, y = 0, xend = 2012, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
fantasy2 <- fantasy %>%
mutate(words_n = if_else(author == "Sapkowski", words * -1, words))
fantasy2 %>%
ggplot() +
geom_segment(aes(x = rok, y = words_n,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text(aes(x = rok,y = words_n,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4) +
geom_point(aes(x = rok,
y = words_n,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
library(ggrepel)
fantasy2 %>%
ggplot() +
geom_segment(aes(x = rok, y = words_n,xend = rok, color = author),yend = 0) + # data = data trzeba ustawić globalnie
geom_segment(aes(x = 1990,
y = 0,
xend = 2020,
yend = 0),
arrow = arrow(length = unit(x = 0.2,
units = 'cm'),
type = 'closed')) +
geom_text_repel(aes(x = rok,y = words_n,
label = title),
hjust = 1.0,
vjust = 1.0,
size = 4,
nudge_x = 5) +
geom_point(aes(x = rok,
y = words_n,
color = author)) +
theme_minimal() +
theme(axis.title.x = element_blank(), # element_blank() usuwa dany element motywu
axis.title.y = element_blank(),
axis.text.y = element_blank(),
text = element_text(size = 10))
## Warning in geom_segment(aes(x = 1990, y = 0, xend = 2020, yend = 0), arrow = arrow(length = unit(x = 0.2, : All aesthetics have length 1, but the data has 12 rows.
## ℹ Please consider using `annotate()` or provide this layer with data containing
## a single row.
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_segment()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_text_repel()`).
## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_point()`).
Prosty przykład ramki danych z datami w formie znakowej.
timeline_data <- data.frame(event = c("Event 1", "Event 2"),
start = c("2020-06-06", "2020-10-01"),
end = c("2020-10-01", "2020-12-31"),
group = "My Events")
Na poniższym wykresie widać problem z właściwą interpretacją dat w formie napisów:
timeline_data %>%
ggplot() +
geom_segment(aes(y = event, #potrzebujemy esetyk y, yend i analogizni z x
xend = end,
x= start,
yend = event,
color = event),
linewidth = 10) +
theme_bw()
Dlatego zamienimy napisy na daty funkcją as.Date:
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event)) +
theme_bw()
Ponieważ w moim systeme daty ustawione są na amerykańskie zmieniam ustawienie na polskie.
Ten sam wykres będzie wyglądał inaczej.
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = event,
xend = end,
x= start,
yend = event,
color= event), linewidth = 15) +
theme_bw()
time <- timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end))
Gantt w jednej linii
timeline_data %>%
mutate(start = as.Date(start),
end = as.Date(end)) %>%
ggplot() +
geom_segment(aes(y = group,
xend = end,
x= start,
yend = group,
colour = event)) +
scale_x_date() +
theme_bw()
Dane dotyczące długości trwania poszczególnych rządów w IIIRP za wikipedią:
premierzyIIIRP <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/premierzyIIIRP.csv")
## Rows: 22 Columns: 7
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): nazwisko, stronnictwo, stronnictwo2
## dbl (2): narodziny, śmierć
## date (2): start, end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
View(premierzyIIIRP)
Jak widać w ostatniej komórce brakuje daty.
Dla uniknięcia problemów z rysowaniem linii można uzupełnić końcową komórkę w zmiennej end datą systemową funkcją Sys.Date, wewnątrz funkcji ymd z biblioteki lubridate. Komórka znajduje się w 7 kolumnie, w 22 wierszu więc robimy to tak:
premierzyIIIRP[22,7] <- lubridate::ymd(Sys.Date())
ggplot(premierzyIIIRP) +
geom_segment(aes(y = stronnictwo,
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo),
linewidth = 10) +
scale_x_date() +
theme_bw()
Uporządkujmy wykorzystując funkcję reorder:
x <- premierzyIIIRP %>%
mutate(group = "group")
premierzyIIIRP %>%
mutate(group = "group") %>%
ggplot() +
geom_segment(aes(y = group,
xend = end,
x= start,
yend = group,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end),
linewidth = 15)) +
scale_x_date() +
theme_bw() -> wykres
## Warning in geom_segment(aes(y = group, xend = end, x = start, yend = group, :
## Ignoring unknown aesthetics: text
library(plotly)
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
ggplotly(wykres, tooltip = "text")
Ustalmy etykiety na osi y na zakończenia kadencji (premierzyIIIRP$end).
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = (premierzyIIIRP$end), # ustawiamy daty na osi x na koniec danego rządu
date_labels = "%Y") + #date_labels ustawione na rok
theme_bw() +
guides(colour = "none") # wyłączamy legendę
To nie jest dobre rozwiązanie bo daty się nakładają
Dlatego stworzymy wektor z unikalnymi datami rocznymi funkcjami unique i year.
lata <- as.data.frame(year(premierzyIIIRP$start))
kadencje <- unique(year(premierzyIIIRP$start))
Wektor który uzyskaliśmy ma format numeryczny.
class(kadencje)
## [1] "numeric"
Następnie zmienimy jego format na date
kadencje <- lubridate::ymd(kadencje)
## Warning: All formats failed to parse. No formats found.
plotly::ggplotly(ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo)) +
scale_x_date(breaks = kadencje,
date_labels = "%y") +
theme_bw() +
guides(colour = "none")
)
z <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end))) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
plotly::ggplotly(z, tooltip = "text")
y <- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 8) + # poszerzymy lini
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3", guide = "none") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y
plotly::ggplotly(y, tooltip = "text") # dodatmy tekst do argumntu tooltip
Dodamy premierów
y1<- ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw()
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
y1
library(ggrepel)
ggplot(premierzyIIIRP) +
geom_segment(aes(y = reorder(stronnictwo, start),
xend = end,
x= start,
yend = stronnictwo,
colour = stronnictwo,
text = paste("",nazwisko,
"<br>",stronnictwo,
"<br>objęcie urzędu:",start,
"<br>złożenie urzędu:",end)),
linewidth = 10) + # poszerzymy lini
geom_text_repel(aes(y = reorder(stronnictwo, start),
x= start,
label = nazwisko)) +
scale_x_date(breaks = kadencje,
date_labels = "%Y") +
scale_color_brewer(palette = "Set3") +
labs(x = "",
y="",
title = "Rządy w III RP") +
theme_bw() +
theme(panel.grid.minor = element_blank())
## Warning in geom_segment(aes(y = reorder(stronnictwo, start), xend = end, :
## Ignoring unknown aesthetics: text
library(scales)
##
## Attaching package: 'scales'
## The following object is masked from 'package:purrr':
##
## discard
## The following object is masked from 'package:readr':
##
## col_factor
library(lubridate)
#install.packages("timevis")
library(timevis)
data <- data.frame(
id = 1:4,
content = c("Item one", "Item two",
"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11",
"2016-01-20", "2016-02-14 15:00:00"),
end = c(NA, NA, "2016-02-04", NA)
)
timevis(data)
?timevis
Spróbujmy stworzyć interaktywny timeline na podstawie danych premierzyIIIRP używając timevis
premierzyIIIRP %>%
rename(content = nazwisko,
title = stronnictwo,
groups = stronnictwo) %>%
timevis()
Stworzymy kalendarz wzorowany na kalendarzu aktywności na githubie.
Dane dotyczące ataków powietrznych na Ukrainę z Kaggle. Według opisu automatycznie ekstraktowane z komunikatów ukraińskich.
# zbiór missile_attacks z kaggle
ataki_rakietowe <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")
## Warning: One or more parsing issues, call `problems()` on your data frame for details,
## e.g.:
## dat <- vroom(...)
## problems(dat)
## Rows: 2236 Columns: 17
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): model, launch_place, target, carrier, affected region, destroyed_d...
## dbl (6): launched, destroyed, not_reach_goal, cross_border_belarus, back_ru...
## dttm (2): time_start, time_end
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
#zbiór missiles_and_uav
środki <- read_csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missiles_and_uav.csv")
## Rows: 46 Columns: 12
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (11): model, category, national_origin, type, launch_platform, name, nam...
## dbl (1): in_sevice
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
W jakim formacie będą dane z informacjami o dacie i czasie jeśli użyjemy funkcji read.csv?
test <- read.csv("https://raw.githubusercontent.com/Tomasz-Olczyk/wizualizacjaR/main/czas/missile_attacks_daily.csv")
glimpse(test)
## Rows: 2,236
## Columns: 17
## $ time_start <chr> "2025-03-15 18:30", "2025-03-14 19:30", "2025-03-…
## $ time_end <chr> "2025-03-16 09:00", "2025-03-15 08:30", "2025-03-…
## $ model <chr> "Shahed-136/131", "Shahed-136/131", "Iskander-M",…
## $ launch_place <chr> "Primorsko-Akhtarsk and Chauda, Crimea and Bryans…
## $ target <chr> "Ukraine", "Ukraine", "Kryvyi Rih", "south", "sou…
## $ carrier <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ launched <dbl> 90, 178, 2, 1, 1, 27, 1, 1, 117, 1, 1, 1, 133, 2,…
## $ destroyed <dbl> 47, 130, 0, 1, 1, 16, 1, 1, 74, 0, 1, 1, 98, 0, 0…
## $ not_reach_goal <dbl> 33, 38, NA, NA, NA, 9, NA, NA, 38, NA, NA, NA, 20…
## $ cross_border_belarus <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ back_russia <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ still_attacking <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
## $ affected.region <chr> "['Chernihiv oblast', 'Kharkiv oblast', 'Odesa ob…
## $ destroyed_details <chr> "{'Odesa oblast': 15, 'Kyiv oblast': NaN, 'Sumy o…
## $ launched_details <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ launch_place_details <chr> "", "", "", "", "", "", "", "", "", "", "", "", "…
## $ source <chr> "kpszsu/posts/pfbid0eLGDvhV4W27vqhevdBBk37HLNhbki…
Łączymy ramkę danych z ramką opisującą typy środków napadu powietrznego żeby wyselekcjonować ataki z użyciem wybranego typu.
Wybieram model i category z ramki środki:
środki_s <- środki %>%
select(model, category)
Wybieram czas, model, wystrzelone z ramki ataki:
ataki_s <- ataki_rakietowe %>%
select(time_end, model,launched, destroyed)
Łączę lewym złączeniem (left_join)
ataki_środki <- left_join(ataki_s, środki_s)
## Joining with `by = join_by(model)`
kal <- ataki_środki %>%
mutate(date = as.Date(time_end)) %>%
complete(date = seq.Date(as.Date("2022-01-01"),
as.Date("2025-03-31"),
by="day"))
ataki_środki <- ataki_środki %>%
mutate(date = as.Date(time_end)) %>%
complete(date = seq.Date(as.Date("2022-01-01"),
as.Date("2025-03-31"),
by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date))
Sumy ataków według kategorii
ataki_cat <- ataki_środki %>%
group_by(date, category) %>%
summarise(wystrzelone = sum(launched)) %>%
ungroup()
## `summarise()` has grouped output by 'date'. You can override using the
## `.groups` argument.
manewrujące <- ataki_cat %>%
filter(category == "cruise missile") %>%
select(date, wystrzelone)
df7 <- manewrujące %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date))
z <- ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradientn(colors = c("yellow", "red4"),
values = scales::rescale(c(1, 115)), # Reskalowanie pełnego zakresu
na.value = "gray88",
limits = c(1, 115)) + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"),
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
caption = "źródło: [Kaggle](https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine)")
z
ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "yellow",
high = "red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous( breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"),
position = "top") +
theme_minimal() +
facet_wrap(~year, ncol = 1)
ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "yellow",
high = "red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"),
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
caption = "źródło: <a href='https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine' target='_blank'>Kaggle</a>")
ggplot(df7, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "yellow",
high = "red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru"),
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_colorbar(title.position = "left",
label.position = "bottom",
barwidth = 10, # Szerszy pasek skali
barheight = 1, # Wysokość paska skali
frame.colour = "black", # Ramka wokół skali
ticks.colour = "black")) +
labs(title = "Rosyjskie ataki pociskami manewrującymi od 28 września 2022",
caption = "źródło: <a href='https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine' target='_blank'>Kaggle</a>")
miesiące <- c("sty", "lut", "mar", "kwi", "maj", "cze", "lip", "sie", "wrz", "paź", "lis", "gru")
balistyczne <- ataki_cat %>%
filter(category == "ballistic missile") %>%
select(date, wystrzelone)
bdf <- balistyczne %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date))
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "orange",
high ="red4",
na.value = "gray88") + # wygląda na to że w 2024 nie ma na value
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące,
position = "bottom") +
theme_gray() +
facet_wrap(~year, ncol = 1) +
theme(panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
b <- ggplot(bdf, aes(y = fct_rev(wday),
x= week,
fill = wystrzelone)) +
geom_tile(colour = "white",
linewidth = 1) +
#dodaję skalę kolorów a'la github na podstawi kolorymetru i funkcji rgb
scale_fill_gradient(low = "yellow",
high ="red4",
na.value = "gray") + #
#poniższa funkcja sprawia że rysują się kwadraty a nie prostokąty
coord_equal() +
scale_x_continuous(breaks = seq(from =1.5, to = 52, by = 4.333), labels = miesiące,
position = "bottom") +
theme_minimal() +
facet_wrap(~year, ncol = 1) +
theme(axis.title.y = element_blank(),
axis.title.x = element_blank(),
legend.position = "bottom",
legend.justification = "right") +
guides(fill = guide_legend(title.position = "left",
label.position = "bottom",
keywidth = 1,
nrow = 1)) +
labs(title = "Rosyjskie ataki pociskami balistycznymi od 28 września 2022",
caption = "źródło: https://www.kaggle.com/datasets/piterfm/massive-missile-attacks-on-ukraine")
b
ggplotly(b)
## Warning in min(x): no non-missing arguments to min; returning Inf
## Warning in max(x): no non-missing arguments to max; returning -Inf
## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [365] is not a sub-multiple or multiple of the number of rows [7]
## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [365] is not a sub-multiple or multiple of the number of rows
## [7]
## Warning in matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), :
## data length [366] is not a sub-multiple or multiple of the number of rows [7]
## Warning in matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow =
## TRUE): data length [366] is not a sub-multiple or multiple of the number of rows
## [7]
## Warning in colorscale_json(trace$colorscale): A colorscale list must of elements
## of the same (non-zero) length
kalendarz <- data.frame(date = seq(as.Date("2025-01-01"),
as.Date("2025-12-31"),
by = "day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::epiweek(date))
kalendarz %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(color = "grey", fill = "white", size = .5) +
geom_text(aes(label = day)) +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
bdf_iso <- balistyczne %>%
complete(date = seq.Date(as.Date("2022-09-28"), as.Date("2025-03-16"), by="day")) %>%
mutate(year = year(date),
month = month(date, label = TRUE),
months = month(date, label = FALSE),
wday = wday(date, label = TRUE),
day = day(date),
week = lubridate::isoweek(date))
bdf %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "yellow",
high = "red4",
name = "liczba rakiet",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
źró∂ło problemu?
problem <- bdf %>%
filter(year == 2023)
Rozwiązanie: trzeba zamienić tydzień ostatniego dnia grudnia na 53
problem <- problem %>%
mutate(week = if_else(month == "gru" & day == 31, 53, week))
problem %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "yellow",
high = "red4",
name = "liczba rakiet",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank()) +
guides(color = "none")
Pierwszy problem:
bdf_iso %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "yellow",
high = "red4",
name = "wystrzelone",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())
glimpse(bdf_iso)
## Rows: 901
## Columns: 8
## $ date <date> 2022-09-28, 2022-09-29, 2022-09-30, 2022-10-01, 2022-10-0…
## $ wystrzelone <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA…
## $ year <dbl> 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022…
## $ month <ord> wrz, wrz, wrz, paź, paź, paź, paź, paź, paź, paź, paź, paź…
## $ months <dbl> 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 1…
## $ wday <ord> śro, czw, ptk, sob, ndz, pon, wto, śro, czw, ptk, sob, ndz…
## $ day <int> 28, 29, 30, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,…
## $ week <dbl> 39, 39, 39, 39, 39, 40, 40, 40, 40, 40, 40, 40, 41, 41, 41…
class(bdf_iso$wday)
## [1] "ordered" "factor"
levels(bdf_iso$wday)
## [1] "ndz" "pon" "wto" "śro" "czw" "ptk" "sob"
bdf_iso$wday <- factor(bdf_iso$wday, levels = c("pon", "wto", "śro", "czw", "ptk", "sob", "ndz"))
Drugi problem
bdf_iso %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "yellow",
high = "red4",
name = "wystrzelone",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())
drugi_problem <- bdf_iso %>%
filter(year == 2023)
bdf_iso$week[bdf_iso$month=="sty" & bdf_iso$week ==52] = 0
bdf_iso <- bdf_iso %>%
mutate(week = if_else(month == "sty" & week == 52, 0, week))
mutate(week = if_else(…)): Funkcja mutate modyfikuje kolumnę week, a if_else pozwala na przypisanie wartości 0 w przypadku, gdy warunki są spełnione (miesiąc to “sty”, a numer tygodnia to 52). Warunek: month == “sty” & week == 52 sprawdza, czy w danym wierszu miesiąc to styczeń, a numer tygodnia to 52. Wartość, jeśli warunek jest spełniony: 0 Wartość, jeśli warunek nie jest spełniony: zachowuje oryginalną wartość w kolumnie week. Efekt: Dzięki temu zapisowi, zamiast bezpośredniej zmiany danych w oryginalnym zbiorze, wartości w kolumnie week zostaną zaktualizowane tylko w tych wierszach, które spełniają określony warunek. Jeśli warunek nie jest spełniony, wartość w kolumnie week pozostanie bez zmian.
bdf_iso %>%
filter(year == 2023) %>%
ggplot(aes(x = wday, y = week)) +
geom_tile(aes(fill = wystrzelone), color = "black", size = .5) +
geom_text(aes(label = day)) +
labs(title = "Rakiety balistyczne wystrzelone przez Rosję",
x = "",
y = "") +
scale_fill_continuous(low = "yellow",
high = "red4",
name = "wystrzelone",
na.value = 'white') +
scale_x_discrete(position = "top") +
scale_y_continuous(trans = "reverse") +
scale_color_manual(values = c("black", "grey")) +
facet_wrap(~month, scales="free_y") +
theme_grey() +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.ticks.x = element_blank())
Sporządźmy anlogiczny kalendarz dla ataków bezpilotowcami (UAV)
#install.packages("calendR")
library(calendR)
## ~~ Package calendR
## Visit https://r-coder.com/ for R tutorials ~~
# Data
set.seed(2)
data <- rnorm(365)
dat <- bdf %>%
filter(year == 2023) %>%
select(wystrzelone)
dat[is.na(dat)] <- 0
# Calendar
calendR(year = 2023,
special.days = dat$wystrzelone,
gradient = TRUE,
low.col = "#FCFFDD",
special.col = "#00AAAE",
legend.pos = "right",
legend.title = "Title")
Rozdział 7 Long, J. D. (2020). Język R: Receptury: analiza danych, statystyka i przetwarzanie grafiki, (K. Sawka, Tłum.). Helion SA.
rozdział 13 z Wickham, H., & Grolemund, G. (2020). Język R: Kompletny zestaw narzędzi dla analityków danych (J. Zatorska, Tłum.). Wydawnictwo Helion.